PC Answers 1995 May

home *** CD-ROM | disk | FTP | other *** search

/ PC Answers 1995 May / PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso / vbits / code / mee / vbdao / visdata / dynagrid.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-10-06 | 20.0 KB | 663 lines

VERSION 2.00 Begin Form fGridFrm BackColor = &H00C0C0C0& ClientHeight = 3105 ClientLeft = 930 ClientTop = 3585 ClientWidth = 6690 Height = 3510 Icon = 0 Left = 870 LinkTopic = "Form1" MDIChild = -1 'True ScaleHeight = 3096 ScaleMode = 0 'User ScaleWidth = 6708 Tag = "Dynaset" Top = 3240 Width = 6810 Begin Grid cGrid FixedCols = 0 FixedRows = 0 Height = 2412 Left = 0 TabIndex = 0 Top = 480 Width = 6732 End Begin PictureBox ViewButtons BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 375 Left = 0 ScaleHeight = 372 ScaleMode = 0 'User ScaleWidth = 5171.606 TabIndex = 1 Top = 24 Width = 5175 Begin CommandButton SortButton Caption = "&Sort" Height = 372 Left = 3720 TabIndex = 9 Top = 0 Width = 612 End Begin CommandButton FilterButton Caption = "Fil&ter" Height = 372 Left = 3120 TabIndex = 8 Top = 0 Width = 612 End Begin CommandButton RefreshButton Caption = "&Redo" Height = 372 Left = 2520 TabIndex = 7 Top = 0 Width = 612 End Begin CommandButton CloseButton Cancel = -1 'True Caption = "&Close" Height = 372 Left = 4320 TabIndex = 6 Top = 0 Width = 612 End Begin CommandButton MoreButton Caption = "&More" Height = 372 Left = 1320 TabIndex = 5 Top = 0 Width = 612 End Begin CommandButton NextButton Caption = "&Next" Height = 372 Left = 120 TabIndex = 4 Top = 0 Width = 612 End Begin CommandButton FirstButton Caption = "&First" Height = 372 Left = 720 TabIndex = 3 Top = 0 Width = 612 End Begin CommandButton FindButton Caption = "F&ind" Height = 372 Left = 1920 TabIndex = 2 Top = 0 Width = 612 End End Option Explicit 'form variables Dim FDS As Dynaset 'current form's dynaset 'Dim FDS As snapshot 'current form's snapshot Dim FDynSt As String 'dynaset open string Dim FTblName As String 'form dynaset table name Dim FCurrentRow As Long 'current row in dynaset Dim FGridRow As Integer 'current grid row Dim FNotFound As Integer 'find not found flag Dim FFindForm As New fFind 'find form Dim FNumbRows As Long 'total number of rows in table Dim FDynaString As String 'dynaset open string Sub cGrid_DblClick () Dim r As Integer 'return from execute sql Dim fn As String 'field name Dim bm As String Dim c As Integer On Error GoTo ZoomErr r = cGrid.Row cGrid.Row = 0 'get field name fn = cGrid.Text cGrid.Row = r 'check to see if the dynaset is updatable If FDS.Updatable = False Then 'only allow memo fields for browsing If FDS(fn).Type <> FT_MEMO Then Exit Sub End If End If 'make sure it's a string or memo field If FDS(fn).Type <> FT_BINARY Then gstZoomData = cGrid.Text fZoom.Caption = fn fZoom.Top = VDMDI.Top + Top + 1200 fZoom.Left = VDMDI.Left + Left + 250 If FDS(fn).Type <> FT_MEMO Then fZoom.cData = gstZoomData fZoom.Height = 1125 Else fZoom.cMemo = gstZoomData fZoom.cMemo.Visible = True fZoom.cData.Visible = False fZoom.Height = 2205 End If If FDS.Bookmarkable And FDS.Updatable Then fZoom.SaveButton.Visible = True fZoom.CloseButton.Visible = True Else fZoom.CloseZoomButton.Visible = True End If fZoom.Show MODAL End If 'update the record If FDS.Bookmarkable Then If gstZoomData <> "__CANCELLED__" Then c = cGrid.Col cGrid.Col = cGrid.Cols - 1 bm = ASCIItoBM((cGrid)) FDS.Bookmark = bm FDS.Edit FDS(fn) = gstZoomData FDS.Update cGrid.Col = c cGrid = gstZoomData End If End If GoTo ZoomEnd ZoomErr: ShowError Resume ZoomEnd ZoomEnd: End Sub Sub cGrid_KeyUp (KeyCode As Integer, Shift As Integer) 'zoom on F4 key press If KeyCode = &H73 Then 'F4 cGrid_DblClick End If End Sub Sub CloseButton_Click () Unload Me End Sub Sub FilterButton_Click () On Error GoTo FilterErr Dim ds1 As Dynaset, ds2 As Dynaset ' Dim ds1 As snapshot, ds2 As snapshot Dim FilterStr As String Dim numbrows As Long 'local number of rows Set ds1 = FDS 'save the dynaset FilterStr = InputBox("Enter Filter Expression:") If Len(FilterStr) = 0 Then Exit Sub FDS.Filter = FilterStr Set ds2 = FDS.CreateDynaset() 'establish the filter ' Set ds2 = FDS.CreateSnapshot() 'establish the filter Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecs(FDS) 'query numb of recs ' FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical caption = "Dynaset: " & FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me Exit Sub ElseIf FNumbRows > gwMaxGridRows Then caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If GoTo FilterEnd FilterErr: ShowError Set FDS = ds1 're-assign back to original Resume FilterEnd FilterEnd: End Sub Sub FindButton_Click () Dim i As Integer, r As Integer, c As Integer On Error GoTo FindErr 'load the column names into the find form 'the 1st time it is loaded If FFindForm.cFieldList.ListCount = 0 Then FFindForm.cFieldList.Clear r = cGrid.Row c = cGrid.Col cGrid.Row = 0 cGrid.Col = 0 For i = 1 To cGrid.Cols - 1 cGrid.Col = cGrid.Col + 1 FFindForm.cFieldList.AddItem cGrid.Text Next cGrid.Row = r cGrid.Col = c End If FindStart: 'used to loop around on not found 'reset the flags gfFindFailed = False gfFromTableView = True MsgBar "Enter Search Parameters", False FFindForm.Show MODAL MsgBar "Searching for record", True If gfFindFailed = True Then Exit Sub FNotFound = False SetHourglass Me 'search for the record cGrid.SetFocus 'start at the top SendKeys "^{Home}" cGrid.Col = 1 cGrid.Row = 0 'move the right column While cGrid.Text <> UCase(gstFindField) If cGrid.Col = cGrid.Cols Then 'reached max col Else cGrid.Col = cGrid.Col + 1 SendKeys "{Right}" End If Wend cGrid.Row = 1 While cGrid.Row < cGrid.Rows - 1 If gfFindMatch = False Then Select Case gstFindOp Case "=" If UCase(cGrid.Text) = UCase(gstFindExpr) Then GoTo AfterWhile Case "<>" If UCase(cGrid.Text) <> UCase(gstFindExpr) Then GoTo AfterWhile Case ">=" If UCase(cGrid.Text) >= UCase(gstFindExpr) Then GoTo AfterWhile Case "<=" If UCase(cGrid.Text) <= UCase(gstFindExpr) Then GoTo AfterWhile Case ">" If UCase(cGrid.Text) > UCase(gstFindExpr) Then GoTo AfterWhile Case "<" If UCase(cGrid.Text) < UCase(gstFindExpr) Then GoTo AfterWhile Case "Like" If UCase(cGrid.Text) Like UCase(gstFindExpr) Then GoTo AfterWhile End Select Else Select Case gstFindOp Case "=" If cGrid.Text = gstFindExpr Then GoTo AfterWhile Case "<>" If cGrid.Text <> gstFindExpr Then GoTo AfterWhile Case ">=" If cGrid.Text >= gstFindExpr Then GoTo AfterWhile Case "<=" If cGrid.Text <= gstFindExpr Then GoTo AfterWhile Case ">" If cGrid.Text > gstFindExpr Then GoTo AfterWhile Case "<" If cGrid.Text < gstFindExpr Then GoTo AfterWhile Case "Like" If cGrid.Text Like gstFindExpr Then GoTo AfterWhile End Select End If cGrid.Row = cGrid.Row + 1 SendKeys "{Down}" Wend FNotFound = True 'didn't find it AfterWhile: ResetMouse Me 'show the first record If FNotFound Then Beep MsgBox "Record Not Found", 48 GoTo FindStart End If DoEvents cGrid.SelStartRow = cGrid.Row cGrid.SelStartCol = 1 cGrid.SelEndRow = cGrid.Row cGrid.SelEndCol = FDS.Fields.Count GoTo FindEnd FindErr: ResetMouse Me ShowError Resume FindEnd FindEnd: MsgBar NULL_STR, False End Sub Sub FirstButton_Click () Dim numbrows As Long 'number of rows On Error GoTo GoFirstError SetHourglass Me MsgBar "Going to first record", True cGrid.SetFocus cGrid.Row = 1 cGrid.Col = 0 'get current starting row in grid If cGrid.Text <> "1" Then FDS.Close Set FDS = gCurrentDB.CreateDynaset(FDS.Name) ' Set FDS = gCurrentDB.CreateSnapshot(FDS.Name) FNumbRows = GetNumbRecs(FDS) ' FNumbRows = GetNumbRecsSS(FDS) If FNumbRows > gwMaxGridRows Then numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If End If cGrid.Col = 1 SendKeys "{Home}" GoTo GoFirstEnd GoFirstError: ShowError Resume GoFirstEnd GoFirstEnd: ResetMouse Me MsgBar NULL_STR, False End Sub Sub Form_Load () Dim t As TableDef 'local table structure Dim sp As Integer 'starting point of table name Dim ep As Integer 'ending point of table name Dim wh As String 'where clause Dim i As Integer, j As Integer Dim fn As String 'field name Dim rc As Integer 'record count Dim numbrows As Long 'local number of rows Dim qd As QueryDef 'querydef for parameterized query Dim p_query As Integer 'param query flag Dim p_val As String 'param value Dim Start1, Finish1, Start2, Finish2 On Error GoTo DynasetErr SetHourglass Me MsgBar "Opening Dynaset", True 'assign the temp string with the select statement 'if it is not empty, otherwise, use the table list name If gfFromSQL = True Then If Len(gstDynaString) = 0 Then FDynSt = fSQL.cSQLStatement Else FDynSt = gstDynaString End If Else FDynSt = fTables.cTableList End If 'check for parameters If InStr(FDynSt, "PARAM1") > 0 Or InStr(gstDynaString, "PARAM1") > 0 Then 'figure out if it is a saved querydef If Mid(UCase(FDynSt), 1, 7) = "SELECT " Then Set qd = gCurrentDB.CreateQueryDef("temp_qd", FDynSt) p_query = 1 Else Set qd = gCurrentDB.OpenQueryDef(fTables.cTableList) p_query = 2 End If 'get the parameter value(s) For i = 1 To 4 p_val = "" p_val = InputBox("Enter the value for parameter " & i) Select Case i Case 1 qd!PARAM1 = p_val Case 2 qd!PARAM2 = p_val Case 3 qd!PARAM3 = p_val Case 4 qd!PARAM4 = p_val End Select If InStr(FDynSt, "PARAM" & i + 1) = 0 And InStr(gstDynaString, "PARAM" & i + 1) = 0 Then Exit For Next End If 'attemp to open the dynaset Start1 = TimeGetTime() If gfFromSQL = True Then If VDMDI.cPassThru.Visible = True And VDMDI.cPassThru = 1 Then Set FDS = gCurrentDB.CreateDynaset(FDynSt, VBDA_SQLPASSTHROUGH) Else Set FDS = gCurrentDB.CreateDynaset(FDynSt) End If Else If p_query = 0 Then If VDMDI.cPassThru.Visible = True And VDMDI.cPassThru = 1 Then FDynSt = "select * from " & StripOwner(FDynSt) Set FDS = gCurrentDB.CreateDynaset(FDynSt, VBDA_SQLPASSTHROUGH) Else Set FDS = gCurrentDB.CreateDynaset(FDynSt) End If Else Set FDS = qd.CreateDynaset() qd.Close If p_query = 1 Then gCurrentDB.DeleteQueryDef "temp_qd" End If End If Finish1 = TimeGetTime() Start2 = TimeGetTime() 'parse off table name to store in global gstTblName wh = NULL_STR sp = InStr(1, UCase(FDynSt), "FROM") If sp > 0 Then 'must be a "select from" statement sp = sp + 5 For ep = sp To Len(FDynSt) 'search for a space or the end of FDynSt If Mid$(FDynSt, ep, 1) = " " Then 'get where clause if there is one wh = Mid$(FDynSt, sp, Len(FDynSt) - sp + 1) Exit For End If Next FTblName = UCase(Mid$(FDynSt, sp, ep - sp)) If Len(wh) = 0 Then wh = FTblName Else 'must be a table name only FTblName = UCase(FDynSt) wh = FTblName End If FDynaString = wh 'show the first record FNumbRows = GetNumbRecs(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical caption = "Dynaset: " & FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 ResetMouse Me Unload Me Exit Sub ElseIf FNumbRows > gwMaxGridRows Then caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If Height = 3800 Width = 5300 Left = 1000 Top = 1000 Finish2 = TimeGetTime() If VDMDI.PrefShowPerf.Checked Then Me.Show MsgBox FNumbRows & " rows found in " & (Finish1 - Start1) / 1000 & " seconds!" & Chr(13) & Chr(10) & (Finish2 - Start2) / 1000 & " seconds to Load Grid!", 48 End If GoTo OkayEnd DynasetErr: If p_query = 1 Then gCurrentDB.DeleteQueryDef "temp_qd" End If ShowError ResetMouse Me MsgBar NULL_STR, False Unload Me Exit Sub Resume OkayEnd OkayEnd: ResetMouse Me MsgBar NULL_STR, False End Sub Sub Form_Resize () On Error Resume Next 'resize grid to window If WindowState <> 1 Then 'not minimized cGrid.Height = Height - 900 cGrid.Width = Width - 100 End If End Sub Sub Form_Unload (Cancel As Integer) On Error Resume Next 'unload the find form Unload FFindForm 'close the associated dynaset FDS.Close MsgBar NULL_STR, False End Sub Sub MoreButton_Click () Dim ret As Integer 'return value from loadgrid On Error Resume Next MsgBar "Getting more records", True If FDS.EOF <> True Then SetHourglass Me ret = LoadGrid(cGrid, FDS, FDynSt, gwMaxGridRows, FCurrentRow) If ret = False Then 'failed so bail out of form FDS.Close Unload Me End If 'set new current row FCurrentRow = FCurrentRow + ret ResetMouse Me End If MsgBar NULL_STR, False End Sub Sub NextButton_Click () Dim c As Integer 'current column On Error GoTo GoNextError c = cGrid.Col cGrid.Col = 0 If Len(cGrid.Text) = 0 Then Beep ElseIf cGrid.Row = gwMaxGridRows Then MoreButton_Click Else cGrid.SetFocus SendKeys "{Down}" End If cGrid.Col = c GoTo GoNextEnd GoNextError: ShowError Resume GoNextEnd GoNextEnd: End Sub 'needed for multi-user situations so 'new records can be viewed imediately Sub RefreshButton_Click () Dim numbrows As Long On Error GoTo RefreshError MsgBar "Reopening Dynaset", True SetHourglass Me Set FDS = gCurrentDB.CreateDynaset(FDS.Name) ' Set FDS = gCurrentDB.CreateSnapshot(FDS.Name) FNumbRows = GetNumbRecs(FDS) ' FNumbRows = GetNumbRecsSS(FDS) If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical caption = "Dynaset: " & FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me ElseIf FNumbRows > gwMaxGridRows Then caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If GoTo RefreshEnd RefreshError: ShowError Resume RefreshEnd RefreshEnd: ResetMouse Me MsgBar NULL_STR, False End Sub Sub SortButton_Click () On Error GoTo SortErr Dim ds1 As Dynaset, ds2 As Dynaset ' Dim ds1 As snapshot, ds2 As snapshot Dim SortStr As String Dim numbrows As Long 'local number of rows Set ds1 = FDS 'save the dynaset SortStr = InputBox("Enter Sort Column:") If Len(SortStr) = 0 Then Exit Sub FDS.Sort = SortStr Set ds2 = FDS.CreateDynaset() 'establish the Sort ' Set ds2 = FDS.CreateSnapshot() 'establish the Sort Set FDS = ds2 'assign back to original dynaset object 'everything must be okay so redisplay form on 1st record FNumbRows = GetNumbRecs(FDS) 'query numb of recs ' FNumbRows = GetNumbRecsSS(FDS) 'query numb of recs If FNumbRows = -1 Then 'error occurred but go on anyway 'because row count is non-critical caption = "Dynaset: " & FTblName numbrows = gwMaxGridRows FCurrentRow = numbrows ElseIf FNumbRows = 0 Then Beep MsgBox "No Records found!", 48 Unload Me Exit Sub ElseIf FNumbRows > gwMaxGridRows Then caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " total rows]" numbrows = gwMaxGridRows FCurrentRow = numbrows Else numbrows = FNumbRows caption = "Dynaset: " & FTblName & " [" & CStr(FNumbRows) & " rows]" End If If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then Unload Me Exit Sub End If GoTo SortEnd SortErr: ShowError Set FDS = ds1 're-assign back to original Resume SortEnd SortEnd: End Sub